COMMENT ⊗   VALID 00016 PAGES VERSION 17-1(12)
RECORD PAGE   DESCRIPTION
 00001 00001
 00003 00002	HISTORY
 00007 00003	Array Semblk, Routine Descriptions
 00015 00004	Array Routine Data
 00019 00005	Array Declaration Routines -- STARY, ENTARY
 00022 00006	 ARRSUB
 00025 00007	 ARRDEC
 00031 00008	OWNARR:	MOVE	ARRBIT,ARYLST		#ARRAYS WITH THESE DIMENSIONS
 00038 00009	
 00043 00010	ADCND:
 00047 00011	DSCR LDYBEG, LDYREP, LDYNO
 00052 00012	DSCR ARYIDX, ARRSBY, ARRSB1
 00054 00013	 FIRST PART SETS UP ARRBIT TO INDICATE EXACT CONDITIONS
 00060 00014	 CHECK UPPER BOUNDS
 00065 00015	DSCR SUBSCR
 00071 00016	DSCR DOSFTY
 00072 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021  102100000014  ⊗;


COMMENT ⊗
VERSION 17-1(12) 3-19-74 BY RHT GO OVER WITH RLS
VERSION 17-1(11) 3-17-74 BY RLS INSTALL TENEX
VERSION 17-0(10) 2-24-74 BY JRL BUG #RK#
VERSION 17-1(9) 2-13-74 BY JRL BUG #RE# STRING ITEMVAR ARRAY NOT A STRING
VERSION 17-1(8) 12-10-73 BY JRL ON BUG PP ONLY GIVE ERROR IF AN OWN ARRAY
VERSION 17-1(7) 12-7-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS (WHERE POSSIBLE)
VERSION 17-1(6) 12-5-73 BY JRL BUG #PP# FIX NO GOOD, GIVE ERROR MESSAGE.
VERSION 17-1(5) 12-5-73 BY JRL BUG #PP# OWN ARRAYS CAUSE PROBLEMS WITH HISEG COMPILATIONS
VERSION 17-1(4) 11-26-73 BY RHT BUG #PE# LDYTOT WAS BEING CLOBBERED IN LDYOUT
VERSION 17-1(3) 11-18-73 BY JRL REMOVE FINAL REFERENCE TO PATSW
VERSION 17-1(2) 9-14-73 BY JRL BUG #OD# SEND TYPE BITS TO ARRAY ITEM ALLOCATOR
VERSION 17-1(1) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSW
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(24) 5-31-73 BY JRL BUG #MO# ANOTHER LDYFLG BUG
VERSION 16-2(23) 5-31-73 
VERSION 16-2(22) 5-14-73 BY RHT BUG #MI# MUST ALWAYS ZERO LDYFLG
VERSION 16-2(21) 5-10-73 BY RHT BUG #MG# LDYFLG HACK WAS ABUSED
VERSION 16-2(20) 5-4-73 BY RHT ARRANGE NOT TO ZERO OWN ARRAYS
VERSION 16-2(19) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
VERSION 16-2(18) 2-23-73 BY JRL BUG #LO# GLOBAL ARRAY ITEMVAR ARRAY NOT GLOBAL ARRAY ITEM
VERSION 16-2(17) 2-9-73 
VERSION 16-2(16) 1-8-73 
VERSION 16-2(15) 1-8-73 BY JRL BUG #KU# DYNAMICALLY CREATE ARRAY ITEMS
VERSION 16-2(14) 1-8-73 
VERSION 16-2(13) 12-6-72 BY DCS BUG #KR# SOME ITEMVARS JUST DON'T HAVE NAMES
VERSION 16-2(12) 11-24-72 BY JRL FIX POTENTIAL GLOBAL ITEM ARRAY BUG
VERSION 16-2(11) 11-6-72 BY JRL ALLOW PRELOADED ITEMVAR ARRAYS
VERSION 16-2(10) 8-29-72 BY KVL FIX SMALL BUG IN LEAP ARRAYS - ARRDEC
VERSION 16-2(9) 8-9-72 BY JRL NEW "GLOBAL" ARRAY HACK
VERSION 16-2(8) 7-18-72 BY DCS BUG #IQ# MAKE JUMP TO ARRAY DECL HAPPEN BEFORE BOUNDS CHECK
VERSION 16-2(7) 6-6-72 BY DCS BUG #HN# ALLOCATE 0 FOR ALL DYNAMIC ARRAYS
VERSION 16-2(6) 5-2-72 BY JRL CHANGE PARAM TO LPCALL(ITMRY)
VERSION 15-2(5) 4-29-72 BY RHT PUT IN MAKE!SAFE & MAKE!UNSAFE FEATURE
VERSION 15-2(4) 2-7-72 BY DCS BUG #GP# WARN IF ATTEMPT TO PRELOAD DYNAMIC ARRAY
VERSION 15-2(3) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
VERSION 15-2(2) 1-10-72 BY DCS BUG #FP# FIX NEGAT BUG ON INDEX FETCH
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER

⊗;
SUBTTL	Array Semblk, Routine Descriptions
	LSTON	(ARRAY)

BEGIN ARRAY
Comment ⊗ (a la D. Poole)
Here are the GRAND and GLORIOUS routines for talking about arrays:


An array descriptor has the form:

ARR:	ptr to BNDBLK,, ptr to next bucket element
	<$PNAME,BITS of various varieties>
TOTDSP:	total displacement(see below),,fixup for array variable
NUMDIM:	#dims,,ACNO of array address
ARLOC:	addr of first data word, if known(lh -1 for STRING)
$VAL2:	global # or item # const semantics if LPARRAY
	<ring pointers>

BNDBLK is the bounds block for this array, described below.
ARLOC(rh) has the address of the first data word of compiled-in
	arrays (OWN on in TBITS) -- top level arrays. (lh as above)
TOTDSP (lh) has [0,0,0] location for array, if known

When a subscript calculation needs to be made, a block of the
	following form is created:

IDXBLK:	ptr partial-calculations,,ptr array descriptor
DIMPRC:	#dimensions processed so far
BNDPNT:	BNDPTR (see below)
NUMDIM:	# dimensions
	<others 0>


Partial-calcs is a TEMP block describing partial index
	calculations to date.

BNDBLK is a block containing information about any constant array
	bounds, if the dimensionality of the array is leq 5.

BNDPTR is a pointer to the set of 2 words in BNDBLK describing
	the current index:

	bits,,upper bound for this dimension
	lower bound,,PRODUCT[i←(current dim+1) to n](size(dimension i)) (mult factor)

bits:	100000 -- NOMUL -- when on, can not do IMULI for size calc
	 40000 -- MULMUL -- ¬NOMUL
	   200 -- LOWFIX -- lower bound fixed
	    40 -- LOWVAR -- ¬LOWFIX
	    20 -- BOTFIX -- lower and upper fixed
	     4 -- SOMVAR -- ¬BOTFIX

The array routines are divided into two sections:
two routines called to declare
arrays (ARRSUB and ARRDEC), and three called to calculate
a subscript when a subscripted variable occurs in an expression
or assignment statement (ARYIDX, ARRSBY, and SUBSCR).


The syntactic contexts for these routines are:

ARDEC E : E SG drarrow ARDEC		ARRSUB
ARDEC E : E ] drarrow  ARDEC		ARRDEC

@IARY [ drarrow  ARID			ARYIDX
@ARY E , drarrow  @ARY			ARRSBY
ARID E ] drarrow  ]			ARRSB1  SUBSCR


Instructions of the following form will be emitted by ARRSUB for each
	index.  ARRX is an AC containing a pointer to the first
	data word of the array (dimension info below it in core).
	AC is the AC containing current index calculations.  The
	conditions under which each kind of instruction is issued
	is given to its right.  Instructions not separated by
	blank lines are alternatives.  There is for each 
	kind of instr. at least one circumstance under which
	no instruction at all will be issued:

MOVE	AC,INDEX			;index not in AC

SKIPL	AC				;¬SAFE and ¬BOTFIX and (¬LSTDX or ¬LOWFIX)
CAIL	AC,lowbnd			;¬SAFE and LOWFIX and ¬BOTFIX and ¬LSTDX

CAMLE	AC,-1-3*dimno+1(ARRX)		;¬SAFE and ¬BOTFIX
CAILE	AC,totsiz			;¬SAFE and BOTFIX

ARERR	dimno,"array name"		;¬SAFE

IMUL	AC,-1-3*dimno+2(ARRX)		;¬LSTDX and ¬NOMUL
IMULI	AC,multiplier(dimno)			;¬LSTDX and NOMUL

ADD	AC,old calculation		;not the first index calc

There is also the feature of preloading the array with good things.
For this operation, the routines LDYBEG, LDYREP, and LDYNO are
called to record on a generalized stack the arguments to load into
the array.


⊗

TOTDSP←←$ADR		;TOTAL DISPLACEMENT (CONSTANT) FOR THIS ARRAY
ARLOC ←←$VAL		;LOCATION OF ARRAY
BNDPNT←←$DATA2		;PTR TO CURRENT ENTRY IN BNDBLK (FOUND IN IDXBLK)
DIMPRC←←$DATA		;#DIMENSIONS PROCESSED TO DATE
NUMDIM←←$ACNO		;NUMBER OF DIMENSIONS FOR THIS ARRAY

ARRBIT←←TBITS2		;BITS AND THINGS ABOUT THIS INDEX
TBLIDX←←SBITS2		;OFTEN HOLDS INDICES (IN ARRSBY)

; BITS USED IN ARRAY ROUTINES
; * INDICATES SUPPLIED BY BNDBLK
; ⊗ INDICATES USED IN ARRSBY
; + INDICATES USED IN SBSCRP


↑ARRBTS:
BIT(SPARE,400000)
BIT(DATMR,200000)	;IF ARRAY IS DATUM OF SOME ITEM		⊗
BIT(NOMUL,100000)	;IF IMULI CANNOT BE DONE THIS INDEX	⊗*
BIT(MULMUL,40000)	;¬NOMUL					⊗*
BIT(ONED,20000)		;ONE DIMENSIONAL ARRAY			⊗
BIT(MANYD,10000)	;¬ONED					⊗
BIT(LSTIDX,4000)	;PROCESSING LAST INDEX			⊗
BIT(NOTLST,2000)	;¬LSTIDX				⊗
BIT(IDXCON,1000)	;THIS INDEX IS A CONSTANT		⊗
BIT(IDXVAR,400)		;¬IDXCON				⊗
BIT(LOWFIX,200)		;LOWER BOUND IS CONSTANT		⊗*
;OWN  ←←   100		;BUILT-IN ARRAY (FROM TBITS)		+
BIT(GOTARR,100)		;HAD TO GET ARRAY DESCR. INTO AN AC	⊗
BIT(LOWVAR,40)		;¬LOWFIX				⊗*
;KNOWALL←←  20		;KNOW ENTIRE OFFSET (FROM SBITS)	+
BIT(SPARE,20)
BIT(BOTFIX,10)		;LOWER AND UPPER BOUNDS CONSTANT	⊗*
NOTCLC←←10		;NO PARTIAL CALCS WHEN SBSCRP CALLED	+
BIT(SOMVAR,4)		;¬BOTFIX				⊗*
SOMCLC←←4		;¬NOTCLC				+
BIT(DANGAR,2)		;NON-SAFE ARRAY (FROM TBITS)		⊗
BIT(SAFEAR,1)		;¬DANGAR				⊗
IFN FTDEBUG,<BLOCK =18>
SUBTTL	Array Routine Data

ZERODATA (ARRAY VARIABLES)

;ABLKPT -- Indirect ptr for ARRSUB for indexing a BNDBLK
?ABLKPT:  0

;ARRDSP -- used to collect total constant displacement (from
;   [0,0,0] loc) during array declarations
?ARRDSP: 0

;ARRSIZ -- collects total array size during declaration
;  (only used if all bounds constant, and Array is OWN)
?ARRSIZ: 0

COMMENT ⊗
ARYBITS -- STARY puts the contents of BITS here when the ARRAY
   attribute is seen during declaration.  This is done because
   many arrays may share the same declarations, and we want these
   bits to remain safe over the entire process
⊗
↑↑ARYBITS: 0

;ARYBLK -- prototype BNDBLK for array.  See ARRAY DSCRs for details
?ARYBLK: BLOCK	=15

;ARYLST -- count of number of arrays with same dimensions, etc.
?ARYLST: 0

;ARYPDL -- QSTACK descriptor (QPDP) to hold Semantics of all
; Arrays with the same types and dimensions. Stored here until 
; the dimensions are known and the arrays can be allocated.
?ARYPDL: 0

?BLKOK: 0		;TEMP ARRAY VARIABLE

?CURENT: 0		;REPEAT FACTOR DURING PRELOAD SPECS

?DIMNO: 0		;COUNTS # DIMS DURING ARRAY DECLARATION

?LDYFLG: 0		;ON DURING ARRAY ALLOC IF PRELOADED OR PRESET
;;#MG# RHT 1 OF 3 	
			; -1 IF REALLY PRELOADED 777777 IF MERELY
			;OWN ARRAY.
;;#MG#

?LDCNST: 0		;ON DURING ARRAY ALLOC IF PRESET

;LDYSTK -- QSTACK dscrptr. -- each word is [XWD rept,Semantics of const]
;   for a PRELOAD value -- collected during PRELOAD spec, used when
;   array is allocated
?LDYSTK: 0

;LDYTAK -- QSTACK dscrptr of first entry in LDYSTK Qstack.  Used to
;    remove elements in order of insertion (via QTAK).
?LDYTAK: 0

?LDYTOT: 0		;TOTAL # WORDS IN PRELOAD SPEC

?LEFMRK: 0		;STRING/ARITH DIFFERENTIATOR DURING DECL.

;NOMULT -- flag during declarations -- turned on if multiples
;   may are no longer constant (must use dope vector for remaining
;   dimensions)
?NOMULT:  0

?OWNWD:  0		;TEMP DURING ARRAY DECLARATIONS

?SIZZ:   0		;TEMP WHILE GENERATING ARRAY-INDEXING CODE

ENDDATA

SUBTTL	Array Declaration Routines -- STARY, ENTARY

DSCR  ARRAY DECLARATION CODE
DES Most Declaration routines are in GEN, but these were moved to
 be close to their variables (OHHHHHHH).
 ENTARY enters an Array name, saves its semantics in ARYPDL
 STARY sets up array variables prior to dimension and size scanning
PRO ENTARY STARY
⊗

↑STARY:	MOVE	B,BITS			;CURRENT COLLECTION OF BITS.
	TLO	B,SBSCRP

↑↑HELSPC: SETZM	OWNWD		;CLEAR TEMP ARRDEC CELLS
	SETZM	ARRSIZ
	SETZM	ARRDSP
	SETZM	SIZZ
	SETZM	BLKOK
	SETZM	ARYBLK
	MOVE	TEMP,[XWD ARYBLK,ARYBLK+1] ;CLEAR PROTOTYPE BNDBLK
	BLT	TEMP,ARYBLK+=10-1
	TLNN	FF,TOPLEV		;IF TOPLEV and ¬EXTERNAL,
	 JRST	 EXRAY
;; #KU# BY JRL (1-8-73) DON'T MAKE ARRAY ITEMS OWN BY DEFAULT
	TDNN	B,[XWD EXTRNL,GLOBL!ITEM]		;MARK ARRAY "OWN".
	 TLO	B,OWN			; SO IT WILL BE COMPILED IN

EXRAY:
	MOVEM	B,ARYBITS		;KEEP THEM SAFE FROM CONSTANTS, ETC.
	MOVEM	B,BITS
	POPJ	P,

↑ENTARY: MOVE	B,ARYBITS		;SAVED BITS
	MOVEM	B,BITS
;;#IQ#3! 7-18-72 DCS MOVED FROM ARRSUB TO HAPPEN BEFORE BOUNDS CALCS
	TLNN	B,OWN			;HOME ANY JUMP, IF DYNAMIC ARRAY
	PUSHJ	P,ENDJMP
	JFCL				;SKIP-RETURNS UNIMPORTANT
	PUSHJ	P,ENTID
	MOVE	A,LPSA
	QPUSH	(ARYPDL)		;SAVE SEMANTICS FOR STARLP CODE
	AOS	ARYLST			;COUNT # ARRAYS WITH SAME DIMS
	SETZM	DIMNO			;NUMBER OF DIMENSIONS
	POPJ	P,			;GO AWAY
SUBTTL	 ARRSUB

DSCR ARRSUB, ARRDEC
PRO ARRSUB ARRDEC
DES ARRSUB collects bounds information -- runs once for each pair
 ARRDEC issues declaration code for all arrays with same type and
 bounds.
SEE Comments at beginning of ARRAY for details
⊗

↑ARRSUB:
	AOS	TEMP,DIMNO		;COUNT DIMENSIONS
	CAILE	TEMP,5			;TOO MANY TO PLAY WITH BLOCK?
	 JRST	 TOMNY			; YES

	LSH	TEMP,1			;*2 TO INDEX ARYBLK
	ADDI	TEMP,ARYBLK-1		;2D WORD OF THIS ENTRY IN ARYBLK
	MOVEM	TEMP,ABLKPT		;STORE IN CORE

TOMNY:	MOVE	TBITS,ARYBITS		;BITS DESCRIBING ARRAY
	TLNE	TBITS,EXTRNL		;IF EXTERNAL, DON'T ALLOCATE
	 POPJ	 P,

	MOVSI	ARRBIT,SOMVAR!LOWVAR!MULMUL	;ASSUME NOT OWN ARRAY
	TLNE	TBITS,OWN		;TEST ASSUMPTION
; OWN (BUILT-IN) ARRAY
	 TLO	 ARRBIT,400000		;INVALID ASSUMPTION
;;#IQ# 7-18-72 DCS ENDJMP CODE MOVED TO ENTARY
	MOVE	PNT,GENLEF+3		;LOWER BOUND SEMANTICS
	GENMOV	(CONV,INSIST!GETD,INTEGR)
	JUMPL	ARRBIT,NOSTKL		;DON'T STACK IF TOP-LEVEL
	GENMOV	(STACK)			;STACK LOWER BOUND

NOSTKL:	TLNN	TBITS,CNST		;IF IT IS CONSTANT,
	 JRST	 NOLOCN
	MOVE	TEMP,$VAL(PNT)		;GET VALUE
	MOVEM	TEMP,@ABLKPT		; SAVE LOWER BOUND
	TLC	ARRBIT,LOWFIX!LOWVAR	; AND INDICATE FIXEDNESS	

NOLOCN:	MOVE	PNT,GENLEF+1		;UPPER BOUND SEMANTICS
	GENMOV	(CONV,INSIST!GETD,INTEGR)
	JUMPL	ARRBIT,NOSTKH		;NO STACKING ETC.
	GENMOV	(STACK)

NOSTKH:	TLNE	ARRBIT,LOWFIX		;DON'T GO FURTHER IF LOWBND VBL
	TLNN	TBITS,CNST		; OR UPPER VBL
	 JRST	 NOHICN

	MOVE	TEMP,$VAL(PNT)		;UPPER BOUND
	SOS	ABLKPT			;SAVE THIS TOO
	HRRM	TEMP,@ABLKPT		;SAVE IT
	TLCA	ARRBIT,BOTFIX!SOMVAR	;MARK BOTH FIXED

NOHICN: SOS	ABLKPT
	JUMPGE	ARRBIT,OKFXD		;BE SURE ALL IS CONST IF
	TLNN	ARRBIT,BOTFIX		; TOPLEV
	 ERR	 <CONSTANT BOUNDS REQD FOR TOP-LEVEL ARRAY>,1
OKFXD:	TLZ	ARRBIT,400000
	HLLM	ARRBIT,@ABLKPT		;UPDATED BITS
	POPJ	P,			;THAT'S ALL
SUBTTL	 ARRDEC

↑ARRDEC:

; FIRST GET A DECENT ARYBLK, FULL OF GOOD THINGS

	MOVE	A,DIMNO			;#DIMENSIONS FOR THESE ARRAYS
	CAIG	A,5			;IF > 5-DM FORGET THE REST OF THIS
	 JRST	BECLEVER		;OTHERWISE PREPARE TO BE CLEVER
	SETOM	BLKOK			;CAN'T USE THE BLOCK
	JRST	MAKARY			;GO MAKE AN ARRAY

BECLEVER:
	SETZM	NOMULT			;WHEN ON, NUMUL GOES
					; ON IN REMAINING BITS
	LSH	A,1			;2*DIMNO FOR INDEXING TABLE
	ADDI	A,1			;FIRST SOJE WILL HAVE NO EFFECT
	MOVEI	C,1			;FIRST MULTIPLIER
	MOVEI	D,0			;COLLECT TOTAL CONSTANT DISPLACMENT
	MOVE	TBITS,ARYBITS		;GET GOOD BITS
	MOVSI	B,BOTFIX		;MAKE TLNN TAKE FIRST TIME

; THIS LOOP CONDITIONS THE ENTRIES IN ARYBLK TO LOOK LIKE THE ABOVE 
; COMMENTS SAID THEY WOULD LOOK -- COMPUTES THE MULTIPLIER VALUES, MAKES NOMUL
; BIT CORRECT IN EACH ENTRY. ALSO COLLECTS THE TOTAL CONSTANT DISPLACEMENT
; WHICH CAN BE USED TO MAKE ARRAY CALCULATIONS FASTER.
; IF "GOGOL", ALSO STACKS (ACTUALLY) THE BOUNDS FOR (ACTUAL) CALL ON ARMAK.


CLEVLUP:
	SOJE	A,MAKARY
	TLNN	B,BOTFIX		;WILL WE STILL BE ABLE TO USE
	 SETOM	 NOMULT			; CONSTANT MULTIPLIERS? -- NO
	MOVE	TEMP,ARYBLK-1(A)	;LOWBND


	HRLM	TEMP,ARYBLK-1(A)	;SAVE IN LH
	HRRM	C,ARYBLK-1(A)		;SAVE MULTIPLIER
	HLLZ	B,ARYBLK-2(A)		;BITS
	TLNN	B,LOWFIX		;IF LOWFIX, 
	 JRST	 CHKMUL
	IMUL	TEMP,C			;COMPILE TOTAL DISPLACEMENT
	SKIPN	NOMULT			; (IF STILL COLLECTING IT)
	 ADD	 D,TEMP			; IN D
	HRRE	TEMP,ARYBLK-2(A)	;UPPER BOUND THIS DIM


	TLNN	B,BOTFIX		;IGNORE IF CAN'T USE
	 JRST	 CHKMUL
	HLRE	PNT,ARYBLK-1(A)		;LOWER BOUND
	SUB	TEMP,PNT		;-LOWER BOUND
	ADDI	TEMP,1			; +1 IS TOTAL SIZE
	SKIPGE	TEMP
	 ERR.	 1,[ASCIZ /UPPER BOUND < LOWER BOUND IN ARRAY DECLARATION/]
	IMUL	C,TEMP			;UPDATE MULTIPLIER
CHKMUL:	SKIPE	NOMULT
	 TLC	 B,NOMUL!MULMUL		;CAN'T USE CONST MULTS NO MORE
	HLLM	B,ARYBLK-2(A)		;STORE PERHAPS UPDATED BITS

	SOJA	A,CLEVLUP		;GO BE MORE CLEVER

MAKARY: TLNN	B,LOWFIX		;CAN'T ASSUME KNOWALL IF HIGH-ORDER
	 SETOM	 NOMULT			;LOW BOUND NOT CONSTANT
	SETZM	LEFMRK			;WILL BE -1 FOR STRING, 0 ELSE
	MOVE	TBITS,ARYBITS		;DESCRIBE THESE ARRAYS
;; #RK#(1 OF 5) ! AN ITEMVAR IS NOT A STRING
	TRNN	TBITS,ITEM!ITMVAR	;
	TRNN	TBITS,STRING		;DOUBLE SIZES FOR STRING ARRAYS
	 JRST	 MKRY1
	SETOM	LEFMRK
	LSH	C,1
	LSH	D,1
MKRY1:	MOVEM	C,ARRSIZ		;SAVE TOTAL ARRAY SIZE
	MOVEM	D,ARRDSP		;AND TOTAL CONSTANT DISPLACMENT
	TLNE	TBITS,EXTRNL		;HANDLE EXTERNALS IN COMPLETELY
	 JRST	 EXARST			; DISJOINT FASHION
	TLNE	TBITS,OWN		;HANDLE OWN ARRAYS SOMEWHAT
	 JRST	 OWNARR			; DIFFERENTLY (DON'T PUT OUT CALLS)

; FINISH SETTING UP CALLING SEQUENCE FOR DYNAMIC ARRAYS

;;#GP# DCS 2-7-72 (1-2) WARNING ON ATTEMPT TO PRELOAD DYNAMIC ARRAY
	SKIPE	LDYFLG			;DON'T LET PRELOADS GO UNNOTED
	 ERR	 <DON'T PRELOAD DYNAMICALLY ALLOCATED ARRAYS>,1
;;#GP# (1)
	MOVE	A,DIMNO			;NUMBER OF DIMENSIONS.
	HRL	A,LEFMRK		;-1 FOR STRING, 0 OTHERWISE
	PUSHJ	P,CREINT		;MAKE AN INTEGER
	GENMOV	(STACK,0)		;STACK IT.
	XPREP
	MOVE	SBITS2,DIMNO		;JUST A PLACE THAT WON'T CHANGE.

	MOVE	A,DIMNO
	LSH	A,1			;MULTIPLY BY TWO
	ADDI	A,1			;AND ACCOUNT FOR WORD WITH #OF DIMS.
	MOVN	TEMP,A			;ALSO RESTORE ADEPTH TO NORMAL
	ADDM	TEMP,ADEPTH

	HRLS	A			;AND COPY IN BOTH HALVES.
	PUSHJ	P,CREINT		;AND MAKE AN INTEGER OF IT.
	MOVE	PNT2,PNT		;SEMANTICS OF THE INTEGER.
	MOVE	ARRBIT,ARYLST		;#ARRAYS WITH THESE DIMENSIONS
	SETZM	OWNWD			;NOT OWN ARRAY
	JRST	STARLP			;GO ALLOCATE ARRAYS
OWNARR:	MOVE	ARRBIT,ARYLST		;#ARRAYS WITH THESE DIMENSIONS


	SETOM	OWNWD			;MARK OWN ARRAY



Comment ⊗ For each array, either issue call to set it up,
	or assemble it in line  ⊗

STARLP:	QPOP	(ARYPDL)		;RESCUE THE SEMANTICS FROM QSTACK
	PUSH	P,A			;SAVE  SEMANTICS UNTIL LATER
	SKIPE	OWNWD			;DYNAMIC OR OWN?
	 JRST	 STOWN			; OWN


AG1:	MOVEI	D,1			;RESTORE THE MAGIC AC NUMBER
AG:	MOVE	LPSA,A			;SEMANTICS OF THIS ARRAY
	PUSHJ	P,GETADL		;FILL UP THINGS.
GLOC <
	TRNN	TBITS,GLOBL		;IF EITHER OF THESE, THEN...
>;GLOC
	TLNN	TBITS,SBSCRP		;NOT IF REAL ARRAY.
	 JRST	[PUSH	P,PNT		;REMEMBER
;; #OD ! (1-2) PASS TYPE BITS TO ITMRY
		 SETZM	BYTES
;; #LO AN ITEMVAR IS NOT AN ITEM
		 TRNN	TBITS,ITMVAR	;IF ITEMVAR NO ITEM NO.
		 TRNN	TBITS,LPARRAY	;IF ITEM TYPE, THEN
		 JRST 	LXXL		;
		 MOVE	PNT,$VAL2(PNT)	;PICK UP SEMANTICS OF ITEM NO.
		 EMIT	<PUSH RP,NOUSAC> ;AND STACK ITEM NUMBER.
;; #OD (2-2)
		 MOVE	A,TBITS
		 PUSHJ  P,ITMTYP
		 HRLZM	A,BYTES
	LXXL:
;; #OD#
GLOC <
		 TRNE	TBITS,GLOBL	;...
		 AOS	LEPGLB		;SAY IT IS GLOBAL.
		PUSHJ	P,GLBST2	;LET GLOBAL REALLY KNOW
>;GLOC
		 LPCALL	(ITMRY)		;THIS WILL DO ALL THE WORK.
		 POP	P,PNT		;RESTORE.
		 JRST	AG0]
	XCALL	<ARMAK>
AG0:	
	HRRI	FF,0
	TLNE	TBITS,SBSCRP		;IF A REGULAR ARRAY.
	GENMOV	(PUT)			;STORE THE AC1 ANSWER.
TESTIT:	TRNN ARRBIT,777776
	JRST ADCND
	MOVE A,[ADD RP,NOUSAC]
	MOVE PNT,PNT2
	PUSHJ P,EMITER
	JRST	ADCND

STOWN:
REN <
	SKIPN	HISW			;REENTRANT COMPILATION AND
	  JRST	DLOSET
	SKIPGE	LDYFLG			;PRELOADED AND
	SKIPN	LDCNST			;PRESET ARRAY?
	  JRST	DLOSET			;NO
	PUSHJ	P,HISET
	SKIPA				;OVER NEXT INST
DLOSET:	PUSHJ	P,LOSET			;SWITCH TO DATA PC
>;REN
	SETOM	OWNWD			;OWN ARRAY
	SKIPE	BLKOK			;>5-D OUTER ARRAYS CAUSE TROUBLE
	 ERR	 <OUTER LEVEL ARRAYS OF OVER 5-D DON'T WORK>,1
	MOVE	TBITS,ARYBITS


REN <
	SKIPN	HISW			;JUMPING AROUND ARRAYS NOT
	 JRST	 NEDJMP			; NECESSARY IN RE-ENTRANT PROGRAM
	SKIPGE	LDYFLG			;UNLESS PRELOADING AND
	SKIPN	LDCNST			; PRESETTING
	 JRST	NOJ			; 
NEDJMP:
>;REN
	MOVE	TEMP,TPROC		;IF JUMP AROUND PROCEDURES HAS
	HLRZ	TEMP,%TLINK(TEMP)	; BEEN ISSUED, WE'LL JUST USE
	MOVE	A,[JRST NOUSAC!NOADDR]
	SKIPN	$SBITS(TEMP)		; IT BELOW TO GET AROUND ARRAY
	PUSHJ	P,EMITER		;OTHERWISE ISSUE JUMP

NOJ:	PUSH	P,PCNT			;WILL NEED FOR FIXUP LATER
	EMIT	<NORLC!NOADDR!NOUSAC>	;0, BECOMES A POINTER LATER
	MOVN	TEMP,DIMNO
	IMULI	TEMP,3
	SUB	TEMP,ARRSIZ
	SUBI	TEMP,5			;-(ARRAY SIZE + 5+3*DIMNO)
	MOVE	A,[XWD -1,NORLC!NOUSAC!USADDR]
	HRL	C,TEMP
	PUSHJ	P,EMITER		;ARRAY SIZE WORD
	HRL	A,LEFMRK		;-1 FOR STRING, 0 OTHERWISE
	HRRI	A,NOUSAC!NOADDR		;WILL BE 0,0,0 WORD
	PUSHJ	P,EMITER		;LEAVE ROOM
	MOVE	D,DIMNO			;THIS LOOP AGAIN!
	LSH	D,1			;*2 TO INDEX BLOCK
	ADDI	D,1			;NULLIFY FIRST SOJE

HEDLUP:	SOJE	D,FINHED
	HLLE	C,ARYBLK-1(D) 		;LOWER BOUND
	HRL	A,C
	HRRI	A,USADDR!NORLC!NOUSAC	;PUT IT OUT
	PUSHJ	P,EMITER
	HRLE	C,ARYBLK-2(D)		;UPPER BOUND THIS DIM
	HRL	A,C			;PUT OUT UPPER
	PUSHJ	P,EMITER		; BOUND
	HRL	C,ARYBLK-1(D) 		;MULTIPLY FACTOR
	EMIT	<USADDR!NORLC!NOUSAC> 	;PUT IT THERE TOO
	SOJA	D,HEDLUP

FINHED:	MOVE	TEMP,DIMNO		;ONE MORE TIME
;;#RK#(2 OF 5) AN ITEMVAR IS NOT A STRING
	TRNN	TBITS,ITEM!ITMVAR
	TRNN	TBITS,STRING
	JRST	.+2
;; #RK#
	MOVNS	TEMP			;#DIMENSIONS, - IF STRING
	HRL	A,TEMP
	HRRI	A,NOUSAC!NORLC!USADDR
	HRL	C,ARRSIZ
	PUSHJ	P,EMITER		;#DIMS,,TOTAL SIZE
	HRL	B,(P)			;FIXUP ADR OF HEAD OF ARRAY
	HRR	B,PCNT			;ADR OF 1ST DATA WORD
	HRRM	B,OWNWD			;SAVE IT
	PUSHJ	P,FBOUT			;LET HDR PNT TO 1ST DATA WORD
;; #MO#! NOW LDYFLG< 0 MEANS PRELOAD, >0 MEANS INNER BLOCK OWN ARRAY
	SKIPL	LDYFLG			;IS THIS A PRELOADED ARRAY ?
	JRST	NOPRE			;NO -- GO AHEAD AS USUAL.....

	PUSHJ	P,LDYOUT		;PUT OUT CONSTANTS INTO ARRAY
	JRST	NOADPC			;DON'T ADD TO PCNT AGAIN


NOPRE:	PUSHJ	P,FRBT			;FORCE OUT BINARY
	MOVE	TEMP,ARRSIZ		;GET OVER ARRAY
	ADDM	TEMP,PCNT		;BY THIS MUCH
NOADPC:	HRL	C,(P)			;HDR ADDRESS AGAIN
	MOVE	A,[XWD 400000,USADDR!NOUSAC]
	PUSHJ	P,EMITER		;SIGN BIT,,ADDR OF HEAD
;; #RK# (3 OF 5) AN ITEMVAR IS NOT A STRING
	TRNN	TBITS,ITEM!ITMVAR
	TRNN	TBITS,STRING		;PUT OUT LINKAGE 
	 JRST	 NSTR			; BLOCK IF STRING ARRAY
	HRRZ	TEMP,ARRSIZ		;COMPUTE NUMBER OF STRINGS
	LSH	TEMP,-1
	HRL	A,TEMP
	HRL	C,OWNWD			;ARRAY LOCATION (1ST STRING)
	HRRI	A,NOUSAC!USADDR	
	PUSHJ	P,EMITER		;PUT IT OUT
	EMIT	<NOADDR!NOUSAC>		;LINK GOES THRU HERE
	MOVEI	B,1			;STRING LINK BLOCK.
	PUSHJ	P,LNKOUT		;PUT OUT LINK BLOCK

NSTR:
REN <
	PUSHJ	P,HISET			;SWITCH BACK TO PROGRAM PC
>;REN
	PUSHJ	P,ENDJMP		;FIX UP JUMP AROUND PROC TO HERE, IF NECC.
	 JRST	 ALJMPD			; NO MORE NEEDED (SEE ENDDEC,PRDEC)
	MOVE	B,(P)			;HDR ADDR
	SUBI	B,1			;JRST ADDR
	HRL	B,PCNT

REN <
	SKIPN	HISW			;MUST JUMP IF NOT REENTRANT PROGRAM
	  JRST ALNDJP
	SKIPGE	LDYFLG			;OR IF PRELOADING
	SKIPN	LDCNST			;AND PRESETTING
	JRST	ALJMPD
>;REN
ALNDJP:
	PUSHJ	P,FBOSWP		;JRST FIXUP
ALJMPD:
;;# # RHT MAKE OWN ARRAYS NOT ZEROED
	TLNE	TBITS,OWN
	TRNE	TBITS,ITEM
	JRST	LDYFOK			;NOT OWN NON-ITEM
	MOVE	A,LEVEL			;STILL ZERO OUTER BLOCKS
	CAIL	A,2			;
;;#MG# ! RHT 2 OF 3  LEAVES LH 0 IF REALLY ONLY OWN
	HLLOS	LDYFLG			;SET THE FLAG (LEAVE LEFT HALF OK)
LDYFOK:
	HRL	C,OWNWD			;ARRAY LOCATION
	MOVE	A,[SETZM NOUSAC!USADDR]	;SETZM 1ST DATA WORD.
	SKIPN	LDYFLG
	PUSHJ	P,EMITER		;PUT IT OUT IF NOT PRE-LOADED ARRAY.
	MOVE	A,[HRLI RTEMP,NOUSAC!USADDR]	;HRLI TEMP, 1ST WORD.
	TRNN	TBITS,LPARRAY		;ALWAYS IF LEAP TYPE ARRAY
	SKIPN	LDYFLG
	PUSHJ	P,EMITER
	TRNE	TBITS,ITEM
	TRNN	TBITS,LPARRAY
	JRST	NORCIT
	PUSH	P,C
; NOW THIS C, THE ARRAY HEADER PCNT, AND THE ARRAY SEMANTICS ARE IN THE PSTACK
	MOVE	PNT,-2(P)		;SO THIS IS HOW TO GET SEMANTICS
	MOVE	PNT,$VAL2(PNT)		;POINTER TO INTEGER AGAIN.
	EMIT	<PUSH RP,NOUSAC>
	LPCALL	(ITMYR)		;ALL THE WORK IS DONE HERE.
	POP	P,C
NORCIT:
	SKIPE	LDYFLG			;PRELOADING ?
	JRST	FXBLK			;YES -- FINISH UP...
	ADD	C,[XWD 1,0]
	EMIT	<HRRI RTEMP,NOUSAC!USADDR> ;HRRI TEMP,2D WORD
	HRRZ	TEMP,OWNWD		;ARRAY LOC
	ADD	TEMP,ARRSIZ
	HRLI	C,-1(TEMP)		;LAST WORD
	EMIT	<BLT RTEMP,NOUSAC!USADDR> ;BLT TEMP,LAST WORD
FXBLK:	
;; #RK# (4 OF 5) ITEMVAR NOT A STRING
	TRNN	TBITS,ITEM!ITMVAR
	TRNN	TBITS,STRING		;NAME LOC IF BILTIN
	JRST	.+2
;; #RK#
	AOS	 OWNWD			;1 PAST IF STRING


	POP	P,B			;HDR ADDR, ONE MORE TIME
	ADDI	B,2			;ADDR OF 0,0,0 WORD
	MOVE	TEMP,OWNWD		;UPDATED ARRAY LOC
	SUB	TEMP,ARRDSP		;TOTAL DISPLACEMENT
	HRL	B,TEMP
	MOVSS	B			;ADDR,FIXUP
	PUSHJ	P,FBOUT
ADCND:

; NOW MAKE A BLOCK FOR EACH ARRAY, SET UP #DIMS, STORE ADDRESS

	MOVE	A,DIMNO			;#DIMENSIONS
;;#HN#! 6-6-72 DCS USE LEFMRK ONLY IF OWNWD (BUILT-IN)-- 0 IF DYNAMIC!
	SKIPE	B,OWNWD			;ADDR OF BEGINNING OF ARRAY
	HRL	B,LEFMRK		;-1 FOR STRING, 0 ELSE
	MOVEI	C,0			;ASSUME ¬KNOWALL
	SKIPN	NOMULT			;TEST ASSUMPTION
	MOVSI	C,KNOWALL		;WRONG
	MOVE	D,OWNWD
	SUB	D,ARRDSP		;DISPLACEMENT, IF KNOWN

	POP	P,PNT		;USE SEMANTICS OF THIS ARRAY, SAVED AT STARLP
	HRLM	A,NUMDIM(PNT)		;NUMBER OF DIMENSIONS


	HRLM	D,TOTDSP(PNT)		;DISPLACEMENT IF KNOWN
	MOVEM	B,ARLOC(PNT)		;LOCATION IF KNOWN
;; #PP# WARN ABOUT FIXUP PROBLEMS
REN <
;;***** ! MAY HAVE SOME FUNNYNESS HERE *****
	ADDI	B,(D)			;VIRTUAL ORIGIN
	SKIPE	HISW			;IF REENTRANT
	TRNN	B,400000		;OR NOT NEGATIVE
	  JRST	NWORRY
	SKIPGE	LDYFLG			;AND PRELOADING AND
	SKIPE	LDCNST			;PRESETTING
	JRST	.+2
	  JRST	NWORRY			;WON'T CAUSE FIXUP PROBLEM
	SKIPE	OWNWD			;DON'T WORRY IF NOT AN OWN ARRAY
	ERR	<VIRTUAL ORIGIN OF OUTER-BLOCK OR OWN ARRAY BEFORE START OF REL FILE.
PROCEED AT YOUR PERIL>,1
NWORRY:
>;REN
	ORM	C,$SBITS(PNT)		;ADD KNOWALL BIT
	SKIPE	BLKOK			;CAN WE PREPARE A BOUNDS BLOCK?
	 JRST	 NOBDBK			; NO BNDBLK

	GETBLK	<LPSA>			;NEW BLOCK TO HOLD IT
	MOVSI	TEMP,ARYBLK		;SOURCE
	HRR	TEMP,LPSA		;DEST
	BLT	TEMP,=10-1(LPSA)	;SAVE BNDBLK INFO
	HRLM	LPSA,%TLINK(PNT)	;PTR TO BNDBLK
NOBDBK:	SOJG	ARRBIT,STARLP		;GET THEM ALL

FINIT:	SETZM	ARYLST			;CLEAR SOMETHING ANYHOW
;;#MI# (1 OF 1) RHT MUST ALWAYS CLEAR LDYFLG
	MOVEI	TEMP,0			;
	EXCH	TEMP,LDYFLG		;ZERO IT OUT
	SETZM	LDCNST			;ALSO ZERO OUT LDCNST FLAG
;;#MI#
;;#MG# RHT ! ONLY NEG IF REALLY PRELOAD
	JUMPL	TEMP,FINLUP		;
	POPJ	P,			;ALL DONE HERE
FINLUP:	QPOP	(LDYSTK)	;POP OFF THINGS.
	JUMPN	A,FINLUP		;UNTIL THE 0 THAT STARTED THINGS.
	POPJ	P,			;DONE AT LAST.


EXARST:	MOVE	B,ARYLST		;ONLY THE ESSENTIALS
	MOVE	SBITS2,DIMNO		;FOR EXTERNAL ARRAYS
;;#GP# DCS 2-7-72 (2-2) WARNING ON PRELOADED EXTERNAL ARRAYS
	SKIPGE	LDYFLG			;DID HE REALLY DO THIS?
	 ERR	 <YOU CAN'T LOAD THAT ARRAY FROM HERE>,1
;;#GP# (2)
	
AGEX:	QPOP	(ARYPDL)		;SEMANTICS FOR THIS ARRAY
	HRLM	SBITS2,$ACNO(A)		;STORE NUMBER OF DIMENSIONS
	SOJG	B,AGEX		;DON'T QUIT UNTIL DONE
	JRST	FINIT			;NOW STOP
DSCR LDYBEG, LDYREP, LDYNO
PRO LDYBEG LDYREP LDYNO
DES EXECS for PRELOAD specifications
⊗
↑LDYSET: SETOM	LDCNST			;INDICATE PRESETTING
	SKIPA				;OVER NEXT INSTRUCTION
↑LDYBEG:SETZM	LDCNST
	MOVEI	A,0
	QPUSH	(LDYSTK)		;PUSH IT ON.
	MOVE	A,LDYSTK
	MOVEM	A,LDYTAK		;FOR THE QTAKE OPERATION.
	SETZM	CURENT
	SETOM	LDYFLG			;TO TELL ARRDEC.
	SETZM	LDYTOT			;AND TOTAL SIZE.
	POPJ	P,

↑LDYREP: GETSEM	(1)			;REPEAT ARGUMENT
	TLNN	TBITS,CNST		;MUST BE CONSTANT.
	ERR	<VARIABLE REPEAT ARGUMENT>,1
	MOVE	A,$VAL(PNT)		;CONSTANT
	HRLM	A,CURENT		;AND SAVE IT.
	POPJ	P,

↑LDYNO:	GETSEM	(1)			;THE CONSTANT TO LOAD
	TLNN	TBITS,CNST		;A REAL CONSTANT?
	ERR	<VARIABLE IN PRELOAD>,1
	MOVE	A,PNT
	HLL	A,CURENT
	TLNN	A,-1			;IF SOME REPEAT ARG.
	TLO	A,1
	SETZM	CURENT
	QPUSH	(LDYSTK)		;STACK IT.
	HLRZ	A,A
	ADDM	A,LDYTOT		;UPDATE TOTAL SIZE.
	POPJ	P,




LDYOUT:	TRNN	TBITS,ITMVAR!INTEGR!FLOTNG!STRING	;ONLY FOR THESE TYPES.
	JRST	[ERR <ONLY ALGEBRAIC PRELOADED ARRAYS>,1
		 JRST LPOPJ]
;;#PE# THERE WERE 4 TERRIBLE INSTRUCTIONS HERE THAT CLOBBERED LDYTOT -- RHT
	PUSH	P,ARRSIZ		;SAVE IT
	PUSH	P,PNT			;GET AN ACCUMULATOR
	PUSH	P,SBITS			;AND ANOTHER
	PUSH	P,TBITS			;AND A THIRD.

	MOVE	B,LDYTAK		;THE QTAKE POINTER.
LDYLOP:	QTAKE	(LDYSTK) ;GET AN ENTRY   XWD REPEAT #,,SEMANTICS OF CONSTANT.
	JRST	LDYFIQ			;NO MORE LEFT.....
	PUSH	P,B			;SAVE QTAKE POINTER.
	MOVE	PNT,A
	HLRZ	D,A			;REPEAT COUNT.
	PUSHJ	P,GETAD			;GET THE GOOD BITS.
	TLNN	TBITS,CNST		;IF NOT, YOU HAVE LOST VERY BIG......
	ERR	<CONSTANTS ONLY IN LOADED ARRAYS>,1


	MOVE	B,-1(P)			;TYPE OF ARRAY
	TRZ	B,ITEM!ITMVAR!LPARRAY	;NOT THESE TYPES.
	GENMOV	(CONV,INSIST)		;ALRIGHT BOYS....
LDYG2:	MOVE	A,$VAL(PNT)		;THIS IS THE CONSTANT.....
	TRNE	TBITS,STRING		;WOW -----
	HRRZ	A,$PNAME(PNT)		;GET THE LENGTH WORD.
	TLZ	FF,RELOC
	PUSHJ	P,CODOUT		;AND PUT OUT THE WORD.....
	TRNN	TBITS,STRING		;ANOTHER WORD IF STRING.
	JRST	LDYG1			;LOOP OTHERWISE.
	MOVS	C,PCNT			;OH DEAR
	EXCH	C,$VAL(PNT)		;HERE (FOR STRINOS) WE STORE THE FIXUP.
	MOVE	A,[POINT 7,USADDR!NOUSAC]
	PUSHJ	P,EMITER		;AND EMIT IT.....
	SOS	ARRSIZ			;DECREASE SIZE LEFT.



LDYG1:	SOSG	ARRSIZ			;MORE LEFT?
	JRST	LDYFIN			;NO
	SOJG	D,LDYG2			;LOOP UNTIL REPEAT EXHAUSTED.
	POP	P,B			;QTAKE POINTER
	JRST	LDYLOP			;AND KEEP GOING.
LDYFIN:	POP	P,B
LDYFIQ:

	POP	P,TBITS			;RESTORE ALL THE SAVED AC'S
	POP	P,SBITS
	POP	P,PNT
	POP	P,ARRSIZ		;AND THE SIZE
;;#PE# USED TO USE A (CLOBBERED) LDYTOT HERE -- RHT -- 11-26-73
	MOVN	B,LDYTOT		;NUMBER OF WORDS
	TRNE	TBITS,STRING		;TWICE AS MANY IF STRING
	ASH	B,1			;TIMES TWO
	ADD	B,ARRSIZ		;GET WHAT IS LEFT
;;#PE#
	JUMPE	B,LPOPJ			;FITS JUST FINE.
	JUMPL	B,[ERR <WARNING -- PRELOADED RANGES TOO LARGE>,1
		   JRST LPOPJ]
	MOVEI	A,0
	TLZ	FF,RELOC
	PUSHJ	P,CODOUT		;MAKE UP THE DIFFERENCE
	SOJG	B,.-1
LPOPJ:	POPJ	P,			;DONE
DSCR ARYIDX, ARRSBY, ARRSB1
PRO ARYIDX ARRSBY ARRSB1
DES ARYIDX initializes for an array-subscripting operation
 ARRSBY is called for every actual index but the last
 ARRSB1 is called for the last index, issues final code
SEE Comments at beginning of ARRAY for details
⊗
↑ARYIDX:
	GETBLK	<PNT2>			;PNT2 PNTS TO IDXBLK
	GETSEM	(1)			;SEMANTICS OF ARR
	HRRZM	PNT,%TBUCK(PNT2)	;SAVE PTR TO ARR IN IDXBLK
	HLRZ	TEMP,%TLINK(PNT)	;PTR TO BNDBLK FOR THIS ARRAY
	MOVEM	TEMP,BNDPNT(PNT2)	;SAVE IN IDXBLK
	HLRZ	TEMP,NUMDIM(PNT)		;#DIMENSIONS
	TLNE	TBITS,FORMAL		;INDEFINITE IF FORMAL
	TRO	TEMP,-1			; (DON'T KNOW REAL NUMBER)
	MOVEM	TEMP,NUMDIM(PNT2)
	MOVEM	PNT2,GENRIG		;THIS IS THE ANSWER
	POPJ	P,

		 JRST LPOPJ]
; FIRST PART SETS UP ARRBIT TO INDICATE EXACT CONDITIONS

↑ARRSBY: SKIPA	ARRBIT,[XWD MANYD!NOTLST!IDXVAR!DANGAR,0] ;NOT LAST INDEX
↑ARRSB1: MOVSI  ARRBIT,MANYD!LSTIDX!IDXVAR!DANGAR	;LAST INDEX
	HRRZ	PNT2,GENLEF+2		;IDXBLK SEMANTICS
	AOS	TBLIDX,DIMPRC(PNT2)	;COUNT #DIMS PROCESSED
	CAMLE	TBLIDX,NUMDIM(PNT2)	;TOO MANY?
	 ERR	 <TOO MANY DIMENSIONS IN SUBSCRIPT>,1
	SOJN	TBLIDX,NOTONE		;CHECK 1-D ARRAY
	TLNE	ARRBIT,LSTIDX		;LSTIDX and DIMPRC=1 implies ONED
	TLC	ARRBIT,ONED!MANYD	;RESET CONDITIONS

NOTONE:	MOVNI	TBLIDX,1(TBLIDX)	; -DIMNO
	IMULI	TBLIDX,3		;INDEX INTO ARRAY DESCRIPTOR
	HRRZ	PNT,%TBUCK(PNT2)	;SEMANTICS OF ARRAY
	PUSHJ	P,GETAD
;; #RK# (5 OF 5)AN ITEMVAR IS NOT A STRING
	TRNN	TBITS,ITEM!ITMVAR
	TRNN	TBITS,STRING		;IF STRING ARRAY, ADJUST
	JRST	.+2
;; #RK#
	 SUBI	 TBLIDX,1		; DISPLACEMENT INTO TABLE
	TLNE	TBITS,SAFE		;ADJUST FOR SAFETY
	 TLC	 ARRBIT,SAFEAR!DANGAR
	TLNE	SBITS,ARTEMP		;IF ARTEMP, THEN DATUM OF ITEMVAR
	 TLO	 ARRBIT,DATMR
	SETZM	SIZZ			;IN CASE NO BITS KNOWN
	SKIPN	B,BNDPNT(PNT2)		;BOUNDS BLOCK POINTER
	 TLO	 ARRBIT,NOMUL!LOWVAR!SOMVAR ;NO BITS, ADD DEFAULT ONES
	 JUMPE	 B,MKTST		; AND SKIP BIT LOAD
	OR	ARRBIT,(B)		;SET UP BITS FROM BOUNDS BLOCK
	MOVEW	(SIZZ,<1(B)>)		;LOWER BOUND AND MULTIPLIER FOR THIS DIM.
	ADDI	B,2
	MOVEM	B,BNDPNT(PNT2)		;UPDATE BOUNDS POINTER

; FINISH SETTING BITS

MKTST:	MOVE	TEMP,GENLEF+1		;INDEX SEMANTICS
	MOVE	TEMP,$TBITS(TEMP)	;TBITS FOR INDEX
	TLNE	TEMP,CNST		;CONSTANT INDEX?
	 TLC	 ARRBIT,IDXCON!IDXVAR	; YES, MAYBE SIMPLER
	TLNE	ARRBIT,LSTIDX		;IF LAST INDEX,
	 TLZ	 ARRBIT,MULMUL!NOMUL	; EASE OF MULTIPLICATION IRRELEVANT


; NOW LOAD ARRAY ADDRESS IF NUMUL or ¬SAFE and SOMVAR

	TLNN	ARRBIT,NOMUL		;MUST IF HAVE TO DO IMUL
	TLNN	ARRBIT,SAFEAR!BOTFIX	;ALSO IF DANGAR and SOMVAR
	 JRST	[TLO	ARRBIT,GOTARR	;AND GOT ARRAY INTO AC.
		 GENMOV  (GET,INDX)	;NO HELP FOR IT.
		 HRROS	ACKTAB(D)	;PROTECT OVER GETTING THE INDEX VARB.
		 HRLS	D		;COPY FOR DOING INDEXING.
		 JRST	.+1]

; MAKE SURE INDEX IS LOADED IF HAVE TO EMIT BOUNDS-CHECKING CODE

	MOVE	PNT,GENLEF+1		;INDEX SEMANTICS
;;#FP#  1-10-72 DCS (1-1)
	GENMOV	(CONV,INSIST!GETD!POSIT!INDX,INTEGR);REQUIRE THESE
				;THINGS, DON'T GET UNLESS NEEDED
; WAS	GENMOV	(CONV,INSIST!GETD,INTEGR) ;REQUIRE AT LEAST THIS MUCH 
;;#FP#   This will avoid some redundant instructions
	MOVEM	PNT,GENLEF+1		;SAVE ANY NEW SEMANTICS
	MOVE	SP,$VAL(PNT)		;IN CASE CONSTANT
	TLNE	ARRBIT,SAFEAR		;FORGET IF SAFE
	 JRST	 GUDGUY

	HRRI	FF,INDX!POSIT		;IN CASE HAVE TO LOAD
	TLNE	ARRBIT,IDXVAR!SOMVAR	;IF IDXCON and BOTFIX, DON'T LOAD
	 GENMOV	(GET)			;1 INSTR ONLY
	MOVEM	PNT,GENLEF+1		;IN CASE SEMANTICS CHANGED

; DO BOUNDS CHECKING -- LOWER

LOWCHK:	HRRI	C,1			;BITS FOR CA(M/I)L
	TLNN	ARRBIT,IDXVAR!LOWVAR	;IF NOTHING MOVES
	 JRST	[HLRE  TEMP,SIZZ	;LOWER
		 CAMGE SP,TEMP		;UNDERFLOW?
		  ERR	 <YOU'LL HAVE SUBSCRIPT UNDERFLOW>,1
		 JRST  CHKOVF]
	TLNN	ARRBIT,IDXVAR!SOMVAR	;WILL WE ISSUE 2D INST?
	MOVEI	C,5			;NO, BITS FOR CA(M/I)GE
	TLNN	ARRBIT,LOWFIX		;TRY FOR "CAIL"?
	 JRST	 DOCAML			; NO, GET FROM ARRAY TABLE

	HLL	C,SIZZ			;LOWER BOUND
	TLNN	C,400000		;NEGATIVE??
	 JRST	 DOCAIL			; NO, WE WIN

	HLRE	A,C		;MAKE INTEGER CONSTANT
	PUSHJ	P,CREINT
	MOVE	A,[CAM USCOND]	;WILL USE CAML
	JRST	LOUT

DOCAML:	HRLI	C,-1(TBLIDX)		;-1-3*DIMNO
	SKIPA	A,[CAM USADDR!NORLC!USX!USCOND] ;WORST CASE
DOCAIL:	MOVE	A,[CAI USADDR!NORLC!USCOND]	;BEST CASE
LOUT:	PUSHJ	P,EMITER
; CHECK UPPER BOUNDS

CHKOVF:	TLNN	ARRBIT,IDXVAR!SOMVAR	;IF NOTHING MOVES
	JRST	[CAILE SP,(ARRBIT)	;CHECK AT COMPILE TIME
		  ERR	<YOU'LL HAVE SUBSCRIPT OVERFLOW>,1
		 JRST  GUDGUY]		;AND OUT

	TLNN	ARRBIT,BOTFIX		;DON'T WORRY ABOUT HIFIX ONLY
	 JRST	 NOCAILE

	HRL	C,ARRBIT		;UPPER BOUND
	TRNN	C,400000		;SEE ABOVE
	 JRST	 DOIMM
	HLRE	A,C
	PUSHJ	P,CREINT
	MOVE	A,[CAMLE]
	JRST	LEOUT

NOCAILE: HRLI	C,-1+1(TBLIDX)		;-1-*DIMNO+1(ARRX)
	SKIPA	A,[CAMLE USADDR!USX!NORLC]
DOIMM:	MOVE	A,[CAILE USADDR!NORLC]
LEOUT:	PUSHJ	P,EMITER		;BOUNDS CHECK INSTRUCTION

; PUT OUT ERROR UUO

MKERR:	MOVEI	TEMP,PNAME-1
	MOVSI	A,(<ARERR>)
	HRRZ	PNT,%TBUCK(PNT2)	;PTR TO ARRAY SEMANTICS
	TLNE	ARRBIT,DATMR		;IS THIS THE DATUM OF AN ARRAY?
;;#KR# DCS 12-6-72 (1-1) SOME ITEMVARS JUST DON'T HAVE NAMES
	HRRZ	PNT,$VAL(PNT)
	JUMPN	PNT,STRERR
	MOVEI	PNT,[=9
		     POINT 7,[ASCII /*UNKNOWN*/]]-$PNAME
STRERR:	PUSH	TEMP,$PNAME(PNT)	;MAKE STRING CONSTANT FOR ERROR GUY
;;#KR#
	PUSH	TEMP,$PNAME+1(PNT)
	PUSHJ	P,STRINS

EMNAM:	EXCH	D,DIMPRC(PNT2)		;THIS DIMENSION AS AC FIELD
	PUSHJ	P,EMITER		;ARERR DIMNO,"ARRAY NAME"
	EXCH	D,DIMPRC(PNT2)

; NOW SEE IF INDEX NEEDED IN AC FOR MULTIPLYING PURPOSES (OR ONED)

GUDGUY:	TLNN	ARRBIT,NOMUL!IDXVAR	;CAN IT ALL BE DONE NOW?
	 JRST	[HRRZ	TEMP,SIZZ	;MULTIPLY FACTOR
		 TLNE	ARRBIT,MULMUL	;SHOULD MULTIPLY BE DONE?
		 IMUL	SP,TEMP		;YES, DO IT
		 ADDM	SP,$VAL(PNT2)	;UPDATE TOTAL DISPLACEMENT
		 MOVE	PNT,GENLEF+1	;ALSO REMOP THE INDEX EXPRESSION.
		 JRST	REVR1]		; AND UNPROTECT THE ARRAY AC
	TLNN	ARRBIT,NOTLST!ONED!DANGAR ;CAN WE ADD INSTEAD OF MOVE?
	 JRST	 ADDREV			;YES

SEMGET:	MOVE	PNT,GENLEF+1		;GET INDEX SEMANTICS AGAIN
	GENMOV	(GET,INDX!POSIT!INSIST!GETD,INTEGR) ;LOAD IT, IF NOT ALREADY
	PUSHJ	P,REMOP			;DO NOT FORGET TO REMOP INDEX.
	TLNE	ARRBIT,LSTIDX		;NEED WE MULTIPLY?
	 JRST	 NOMLT			; NOPE
	TLNE	ARRBIT,NOMUL		;CAN WE DO AN IMULI?
	 JRST	 DOMUL			; NO, AN IMUL

DOMULI:	HRL	C,SIZZ			;MULTIPLY FACTOR
	TLNN	C,-1			;0 MULTIPLE INVALID
	 ERR	 <DRYROT --0 MULTIPLE??>
	TLNN	C,777776		;1?
	 JRST	 NOMLT			; DON'T MULTIPLY BY 1
	EMIT	<IMULI NORLC!USADDR>
	JRST	NOMLT

DOMUL:	HRLI	C,1(TBLIDX)		;-1-3*DIMNO+2 -- MULTIPLY FACTOR
	EMIT	<IMUL USADDR+USX+NORLC> ;IMUL AC,-1-3*DIMNO+2(ARRX)

; NOW ADD OR CREATE PARTIAL TEMP

NOMLT:	PUSHJ	P,MARKINT		;MARK AS INTEGER.
	LEFT	PNT2,%TLINK,,
	HRLM	PNT,%TLINK(PNT2)	;GET OLD SEMANTICS, STORE NEW
	MOVEI	PNT,0			;MAKE REMOP HARMLESS IF JUMP IS TAKEN
	JUMPE	LPSA,REVR1;		;FRST INDX CLC, UNPROTECT ARRAY AC
	PUSHJ	P,GETADL		;SEMANTICS OF OLD PARTIAL
REVRET:	EMIT	<ADD>			;ADD AC,OLD PARTIAL
REVR1:	MOVS	TEMP,D			;ARRAY INDEX REG
	TLNE	ARRBIT,GOTARR		;UNPRTCT IF WE PICKED UP ARRAY DSCRPTR
	HRRZS	ACKTAB(TEMP)
	JRST	REMOP			;REMOVE OLD AND RETURN

ADDREV:	HLRZ	PNT,%TLINK(PNT2)	;ADD IN THE OPPOSITE DIRECTION
	JUMPE	PNT,SEMGET		; UNLESS THIS IS FIRST INDEX
					;(IT SHOULDN'T BE BECAUSE OF ABOVE CONDITIONS
	GENMOV	(GET,INDX!GETD)		;GET OLD TEMP BACK
	MOVE	PNT,GENLEF+1		;SEMANTICS OF THIS INDEX
	GENMOV	(CONV,INSIST!POSIT!GETD,INTEGR)	;MAKE SURE IT IS THE RIGHT SHAPE
	JRST	REVRET			;ADD IN INVERSE ORDER


DSCR SUBSCR
PRO SUBSCR
DES Issues final code for array subscripting operation
⊗
↑SUBSCR: HRRZ	PNT2,GENLEF+2		;IDXBLK SEMANTICS
	HRRZ	LPSA,%TBUCK(PNT2)	;SEMANTICS OF ARRAY
	HLRZ	PNT,%TLINK(PNT2)	;SEMANTICS OF PARTIAL CALCS
	HRRE	TEMP,NUMDIM(PNT2)	;CHECK CORRECT CALL
	JUMPL	TEMP,SUBIGN		;CAN'T CHECK IT
	CAME	TEMP,DIMPRC(PNT2)	;CHECK IT
	 ERR	 <NOT ENOUGH SUBSCRIPTS SUPPLIED TO >,3
SUBIGN:	EXCH	LPSA,PNT2		;PNT2 IS ARRAY SEMANTICS
	MOVE	B,DIMPRC(LPSA)		;ACTUAL NUMBER OF DIMENSIONS SEEN.
	MOVE	TBLIDX,$VAL(LPSA)	;GET TOTAL CONTRIBUTION OF CONSTS
	FREBLK	()			;RELEASE IDXBLK
	MOVE	SP,$TBITS(PNT2)		;TBITS FROM ARRAY (GET OWN)
;; #RE# (1 OF 2) A STRING ITEMVAR ARRAY OR STRING ARRAY ITEMVAR ARRAY IS NOT A STRING
	TRNE	SP,ITMVAR
	TRZ	SP,STRING
;; #RE#
	MOVEI	ARRBIT,0		;FLAGS FOR THIS CALC
	SKIPE	PNT			;ANY PARTIAL CALCS?
	 TLO	 ARRBIT,NOTCLC!SOMCLC	; YES (NOTCLC STORED INVERTED)
	TLNN	SP,OWN			;BUILT-IN ARRAY?
	 TLO	 ARRBIT,OWN		; NO, SET INVERTED SENSE
	TRNE	SP,STRING		;STRING ARRAY?
	 LSH	 TBLIDX,1		; YES, SHIFT THIS
	MOVE	TEMP,$SBITS(PNT2)	;NOW CHECK TOTDSP KNOWLEDGE
	TLNN	TEMP,KNOWALL		;HAVE WE GOT ENTIRE OFFSET?
	 TLO	 ARRBIT,KNOWALL		;NO (KNOWALL STORED INVERTED)
	JUMPE	PNT,NOGT		;NO PARTIAL CALCS
	GENMOV	(GET,GETD!INDX)		;MAKE SURE IN AC
	HRL	SP,D			;SAVE AC OF PARTIAL CALCS
	HRLI	C,1			;GET READY FOR LSH IF STRING
	MOVE	A,[LSH USADDR!NORLC]
	TRNE	SP,STRING
	PUSHJ	P,EMITER		;DOUBLE INDEX
NOGT:	EXCH	PNT,PNT2		;NOW PNT IS ARRAY SEMANTICS
	PUSHJ	P,GETAD			;GET BITS
;; #RE# (2 OF 2) AGAIN STRING ITEMVAR NOT STRING
	TRNE	TBITS,ITMVAR
	TRZ	TBITS,STRING
;; #RE#

	TLCN	ARRBIT,NOTCLC!OWN!KNOWALL ;INVERT AND TEST
	 JRST	 FXDARR			;CAN DO IT ALLL AT COMPILE TIME

; NOW ADJUST DISPLACEMENT BY TOTDSP IF KNOWALL

	TLNN	ARRBIT,KNOWALL		;WELL?
	 JRST	 DONKNO			;NEED [0,0,0] WORD

	HLRE	TEMP,TOTDSP(PNT)	;TOTDSP&POSSIBLY ARRAY ADDR
	ADD	TBLIDX,TEMP		;NOW TBLIDX HAS GOOD DISPL FIELD
	TLNE	ARRBIT,OWN!NOTCLC	;IF ¬OWN and PARTIAL CALCS,
	 JRST	 GETARP			; CAN ADD ARRAY PTR
	EMIT	<ADD>			;DO IT
	JRST	MRKIDX			;MAKE AN INDEXED TEMP, FINISH OUT

GETARP:	TLNE	ARRBIT,OWN		;KNOWALL,¬OWN,¬PARTIAL CALCS?
	 JRST	 MRKIDX			;NO, KNOWALL,OWN,PARTIAL CALCS

	GENMOV	(GET,INDX)		;GET ARRAY ADDR TO INDXABLE AC
	JRST	MRKIDX

DONKNO:	GENMOV	(GET,INDX)		;MAKE SURE ARRAY ADDR IS UP
	HRLS	D			;SAVE AC AS INDEX POS
	HLR	D,SP			;GET AC OF PARTIAL CALCS BACK
;	MOVE	B,DIMPRC(IDXBLK)	;NUMBER OF DIMENSIONS ACTUALLY SEEN.
	IMULI	B,-3
	TRNE	TBITS,STRING		;GET POINTER TO [0,0,0] WORD
	 ADDI	 B,-1
	HRLI	C,-2(B)			;TO ADDR FIELD FOR EMITER
	JUMPN	PNT2,ADD000		;CAN ADD IF HAVE PARTIAL CALCS
	PUSHJ	P,GETAN0		;NEED INDEXABLE AC FOR 000 WORD
	SKIPA	A,[MOVE USX!USADDR!NORLC]

ADD000:	MOVE	A,[ADD USX!USADDR!NORLC]
	PUSHJ	P,EMITER		;GAIN ACCESS

MRKIDX:	MOVE	ARRBIT,$TBITS(PNT)	;GET TYPE BITS BACK
	PUSHJ	P,REMOP			;REMOVE ARRAY
	SKIPE	PNT,PNT2		;PARTIAL CALCS
	PUSHJ	P,REMOP			; REMOVE IF ANY
	PUSHJ	P,MARKINT		;MAKE AN INTEGER TEMP.
	TLZ	ARRBIT,-1≠OWN		;TURN OFF MOST LH BITS
	MOVEM	ARRBIT,$TBITS(PNT)	;THESE ARE THE REAL THING
	MOVSI	SBITS,INUSE!ARTEMP!INDXED!PTRAC
	MOVEM	SBITS,$SBITS(PNT)	;ALWAYS THE SAME
	MOVEM	TBLIDX,$VAL(PNT)	;DISPL FOR REFERENCES
	MOVEM	PNT,GENRIG		;RESULTS
	POPJ	P,

FXDARR:	HLRE	TEMP,TOTDSP(PNT)	;GET ALWAYS CONSTANT DISPL
	ADD	TBLIDX,TEMP		;INCREMENT BY CONSTANT CONTRIBUTIONS
	TLZ	TBITS,-1		;TYPE OF RESULT IN RH
	MOVSI	SBITS,FIXARR		;SPECIAL RESULT
	PUSHJ	P,GETTEM		;NEED TEMP BLOCK
	MOVEM	TBLIDX,$ADR(LPSA)	;NON-FIXUPABLE ADDRESS RESULT
	MOVEM	LPSA,GENRIG		;RESULT
	JRST	REMOP			;REMOVE "ARRAY" FROM USE
DSCR DOSFTY
DES   EXEC TO CHANGE THE SAFETY STATUS OF ARRAYS
⊗

↑DOSFTY:
	MOVE	LPSA,GENLEF+1		;PICK UP ARRAY ID
	MOVE	TBITS,$TBITS(LPSA)	;TYPEE BITS
	JRST	.+1(B)			; SKIP IF MAKE!UNSAFE
	TLOA	TBITS,SAFE		;MAKE SAFE
	TLZ	TBITS,SAFE		;MAKE UNSAFE
	MOVEM	TBITS,$TBITS(LPSA)	;PUT BITS BACK
	POPJ	P,


BEND ARRAY

SUBTTL	EXECS for Binary Algebraic Operators